home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / tclsrc / help.tcl < prev    next >
Encoding:
Text File  |  1994-01-11  |  10.4 KB  |  338 lines
  1. #
  2. # help.tcl --
  3. #
  4. # Tcl help command. (see TclX manual)
  5. # 
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992-1993 Karl Lehenbauer and Mark Diekhans.
  8. #
  9. # Permission to use, copy, modify, and distribute this software and its
  10. # documentation for any purpose and without fee is hereby granted, provided
  11. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12. # Mark Diekhans make no representations about the suitability of this
  13. # software for any purpose.  It is provided "as is" without express or
  14. # implied warranty.
  15. #------------------------------------------------------------------------------
  16. # The help facility is based on a hierarchical tree of subjects (directories)
  17. # and help pages (files).  There is a virtual root to this tree. The root
  18. # being the merger of all "help" directories found along the $auto_path
  19. # variable.
  20. #------------------------------------------------------------------------------
  21. # $Id: help.tcl,v 3.1 1994/01/11 05:18:48 markd Exp $
  22. #------------------------------------------------------------------------------
  23. #
  24.  
  25. #@package: TclX-help help helpcd helppwd apropos
  26.  
  27. #------------------------------------------------------------------------------
  28. # Return a list of help root directories.
  29.  
  30. proc help:RootDirs {} {
  31.     global auto_path
  32.     set roots {}
  33.     foreach dir $auto_path {
  34.         if [file isdirectory $dir/help] {
  35.             lappend roots $dir/help
  36.         }
  37.     }
  38.     return $roots
  39. }
  40.  
  41. #------------------------------------------------------------------------------
  42. # Take a path name which might have "." and ".." elements and flatten them out.
  43. # Also removes trailing and adjacent "/", unless its the only character.
  44.  
  45. proc help:FlattenPath pathName {
  46.     set newPath {}
  47.     foreach element [split $pathName /] {
  48.         if {"$element" == "." || [lempty $element]} continue
  49.  
  50.         if {"$element" == ".."} {
  51.             if {[llength [join $newPath /]] == 0} {
  52.                 error "Help: name goes above subject directory root" {} \
  53.                     [list TCLXHELP NAMEABOVEROOT $pathName]
  54.             }
  55.             lvarpop newPath [expr [llength $newPath]-1]
  56.             continue
  57.         }
  58.         lappend newPath $element
  59.     }
  60.     set newPath [join $newPath /]
  61.  
  62.     # Take care of the case where we started with something line "/" or "/."
  63.  
  64.     if {("$newPath" == "") && [string match "/*" $pathName]} {
  65.         set newPath "/"
  66.     }
  67.         
  68.     return $newPath
  69. }
  70.  
  71. #------------------------------------------------------------------------------
  72. # Given a pathName relative to the virtual help root, convert it to a list of
  73. # real file paths.  A list is returned because the path could be "/", returning
  74. # a list of all roots. The list is returned in the same order of the auto_path
  75. # variable. If path does not start with a "/", it is take as relative to the
  76. # current help subject.  Note:  The root directory part of the name is not
  77. # flattened.  This lets other commands pick out the part relative to the
  78. # one of the root directories.
  79.  
  80. proc help:ConvertPath pathName {
  81.     global TCLXENV
  82.  
  83.     if {![string match "/*" $pathName]} {
  84.         if {"$TCLXENV(help:curSubject)" == "/"} {
  85.             set pathName "/$pathName"
  86.         } else {
  87.             set pathName "$TCLXENV(help:curSubject)/$pathName"
  88.         }
  89.     }
  90.     set pathName [help:FlattenPath $pathName]
  91.  
  92.     # If the virtual root is specified, return a list of directories.
  93.  
  94.     if {$pathName == "/"} {
  95.         return [help:RootDirs]
  96.     }
  97.  
  98.     # Not the virtual root find the first match.
  99.  
  100.     foreach dir [help:RootDirs] {
  101.         if [file readable $dir/$pathName] {
  102.             return [list $dir/$pathName]
  103.         }
  104.     }
  105.     error "\"$pathName\" does not exist" {} \
  106.         [list TCLXHELP NOEXIST $pathName]
  107. }
  108.  
  109. #------------------------------------------------------------------------------
  110. # Return the virtual root relative name of the file given its absolute path.
  111. # The root part of the path should not have been flattened, as we would not
  112. # be able to match it.
  113.  
  114. proc help:RelativePath pathName {
  115.     foreach dir [help:RootDirs] {
  116.         if {[csubstr $pathName 0 [clength $dir]] == $dir} {
  117.             set name [csubstr $pathName [clength $dir] end]
  118.             if {$name == ""} {set name /}
  119.             return $name
  120.         }
  121.     }
  122.     if ![info exists found] {
  123.         error "problem translating \"$pathName\"" {} [list TCLXHELP INTERROR]
  124.     }
  125. }
  126.  
  127. #------------------------------------------------------------------------------
  128. # Given a list of path names to subjects generated by ConvertPath, return
  129. # the contents of the subjects.  Two lists are returned, subjects under that
  130. # subject and a list of pages under the subject.  Both lists are returned
  131. # sorted.  This merges all the roots into a virtual root.  pathName is the
  132. # string that was passed to ConvertPath and is used for error reporting.
  133. # *.brk files are not returned.
  134.  
  135. proc help:ListSubject {pathName pathList subjectsVar pagesVar} {
  136.     upvar $subjectsVar subjects $pagesVar pages
  137.  
  138.     set subjects {}
  139.     set pages {}
  140.     set foundDir 0
  141.     foreach dir $pathList {
  142.         if ![file isdirectory $dir] continue
  143.         set foundDir 1
  144.         foreach file [glob -nocomplain $dir/*] {
  145.             if [string match *.brf $file] continue
  146.             if [file isdirectory $file] {
  147.                 lappend subjects [file tail $file]/
  148.             } else {
  149.                 lappend pages [file tail $file]
  150.             }
  151.         }
  152.     }
  153.     if !$foundDir {
  154.         if [cequal $pathName /] {
  155.             global auto_path
  156.             error "no \"help\" directories found on auto_path ($auto_path)" {} \
  157.                 [list TCLXHELP NOHELPDIRS]
  158.         } else {
  159.             error "\"$pathName\" is not a subject" {} \
  160.                 [list TCLXHELP NOTSUBJECT $pathName]
  161.         }
  162.     }
  163.     set subjects [lsort $subjects]
  164.     set pages [lsort $pages]
  165.     return {}
  166. }
  167.  
  168. #------------------------------------------------------------------------------
  169. # Display a line of output, pausing waiting for input before displaying if the
  170. # screen size has been reached.  Return 1 if output is to continue, return
  171. # 0 if no more should be outputed, indicated by input other than return.
  172. #
  173.  
  174. proc help:Display line {
  175.     global TCLXENV
  176.     if {$TCLXENV(help:lineCnt) >= 23} {
  177.         set TCLXENV(help:lineCnt) 0
  178.         puts stdout ":" nonewline
  179.         flush stdout
  180.         gets stdin response
  181.         if {![lempty $response]} {
  182.             return 0}
  183.     }
  184.     puts stdout $line
  185.     incr TCLXENV(help:lineCnt)
  186. }
  187.  
  188. #------------------------------------------------------------------------------
  189. # Display a help page (file).
  190.  
  191. proc help:DisplayPage filePath {
  192.  
  193.     set inFH [open $filePath r]
  194.     while {[gets $inFH fileBuf] >= 0} {
  195.         if {![help:Display $fileBuf]} {
  196.             break}
  197.     }
  198.     close $inFH
  199. }    
  200.  
  201. #------------------------------------------------------------------------------
  202. # Display a list of file names in a column format. This use columns of 14 
  203. # characters 3 blanks.
  204.  
  205. proc help:DisplayColumns {nameList} {
  206.     set count 0
  207.     set outLine ""
  208.     foreach name $nameList {
  209.         if {$count == 0} {
  210.             append outLine "   "}
  211.         append outLine $name
  212.         if {[incr count] < 4} {
  213.             set padLen [expr 17-[clength $name]]
  214.             if {$padLen < 3} {
  215.                set padLen 3}
  216.             append outLine [replicate " " $padLen]
  217.         } else {
  218.            if {![help:Display $outLine]} {
  219.                return}
  220.            set outLine ""
  221.            set count 0
  222.         }
  223.     }
  224.     if {$count != 0} {
  225.         help:Display [string trimright $outLine]}
  226.     return
  227. }
  228.  
  229. #------------------------------------------------------------------------------
  230. # Display help on help, the first occurance of a help page called "help" in
  231. # the help root.
  232.  
  233. proc help:HelpOnHelp {} {
  234.     set helpPage [lindex [help:ConvertPath /help] 0]
  235.     if [lempty $helpPage] {
  236.         error "No help page on help found" {} \
  237.             [list TCLXHELP NOHELPPAGE]
  238.     }
  239.     help:DisplayPage $helpPage
  240. }
  241.  
  242. #------------------------------------------------------------------------------
  243. # Help command.
  244.  
  245. proc help {{what {}}} {
  246.     global TCLXENV
  247.  
  248.     set TCLXENV(help:lineCnt) 0
  249.  
  250.     # Special case "help help", so we can get it at any level.
  251.  
  252.     if {($what == "help") || ($what == "?")} {
  253.         help:HelpOnHelp
  254.         return
  255.     }
  256.  
  257.     set pathList [help:ConvertPath $what]
  258.     if [file isfile [lindex $pathList 0]] {
  259.         help:DisplayPage [lindex $pathList 0]
  260.         return
  261.     }
  262.  
  263.     help:ListSubject $what $pathList subjects pages
  264.     set relativeDir [help:RelativePath [lindex $pathList 0]]
  265.  
  266.     if {[llength $subjects] != 0} {
  267.         help:Display "\nSubjects available in $relativeDir:"
  268.         help:DisplayColumns $subjects
  269.     }
  270.     if {[llength $pages] != 0} {
  271.         help:Display "\nHelp pages available in $relativeDir:"
  272.         help:DisplayColumns $pages
  273.     }
  274. }
  275.  
  276.  
  277. #------------------------------------------------------------------------------
  278. # helpcd command.  The name of the new current directory is assembled from the
  279. # current directory and the argument.
  280.  
  281. proc helpcd {{dir /}} {
  282.     global TCLXENV
  283.  
  284.     set pathName [lindex [help:ConvertPath $dir] 0]
  285.  
  286.     if {![file isdirectory $pathName]} {
  287.         error "\"$dir\" is not a subject" \
  288.             [list TCLXHELP NOTSUBJECT $dir]
  289.     }
  290.  
  291.     set TCLXENV(help:curSubject) [help:RelativePath $pathName]
  292.     return
  293. }
  294.  
  295. #------------------------------------------------------------------------------
  296. # Helpcd main.
  297.  
  298. proc helppwd {} {
  299.         global TCLXENV
  300.         echo "Current help subject: $TCLXENV(help:curSubject)"
  301. }
  302.  
  303. #------------------------------------------------------------------------------
  304. # apropos command.  This search the 
  305.  
  306. proc apropos {regexp} {
  307.     global TCLXENV
  308.  
  309.     set TCLXENV(help:lineCnt) 0
  310.  
  311.     set ch [scancontext create]
  312.     scanmatch -nocase $ch $regexp {
  313.         set path [lindex $matchInfo(line) 0]
  314.         set desc [lrange $matchInfo(line) 1 end]
  315.         if {![help:Display [format "%s - %s" $path $desc]]} {
  316.             set stop 1
  317.             return}
  318.     }
  319.     set stop 0
  320.     foreach dir [help:RootDirs] {
  321.         foreach brief [glob -nocomplain $dir/*.brf] {
  322.             set briefFH [open $brief]
  323.             scanfile $ch $briefFH
  324.             close $briefFH
  325.             if $stop break
  326.         }
  327.         if $stop break
  328.     }
  329.     scancontext delete $ch
  330. }
  331.  
  332. #------------------------------------------------------------------------------
  333. # One time initialization done when the file is sourced.
  334. #
  335. global TCLXENV
  336.  
  337. set TCLXENV(help:curSubject) "/"
  338.